home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / os2 / adaptor.zip / ADAPT.ZIP / adaptor / src / reductio.c < prev    next >
Text File  |  1994-01-03  |  26KB  |  1,060 lines
  1. # include "Reductio.h"
  2. # include "yyReduc.w"
  3. # include <stdio.h>
  4. # if defined __STDC__ | defined __cplusplus
  5. #  include <stdlib.h>
  6. # else
  7.    extern void exit ();
  8. # endif
  9. # include "Tree.h"
  10. # include "Definiti.h"
  11.  
  12. # ifndef NULL
  13. # define NULL 0L
  14. # endif
  15. # ifndef false
  16. # define false 0
  17. # endif
  18. # ifndef true
  19. # define true 1
  20. # endif
  21.  
  22. # ifdef yyInline
  23. # define yyALLOC(tree, free, max, alloc, nodesize, make, ptr, kind) \
  24.   if ((ptr = (tree) free) >= (tree) max) ptr = alloc (); \
  25.   free += nodesize [kind]; \
  26.   ptr->yyHead.yyMark = 0; \
  27.   ptr->Kind = kind;
  28. # else
  29. # define yyALLOC(tree, free, max, alloc, nodesize, make, ptr, kind) ptr = make (kind);
  30. # endif
  31.  
  32. # define yyWrite(s) (void) fputs (s, yyf)
  33. # define yyWriteNl (void) fputc ('\n', yyf)
  34.  
  35. # line 33 "Reductions.puma"
  36.  
  37.  
  38. # include <stdio.h>
  39. # include "Tree.h"
  40. # include "Idents.h"
  41. # include "protocol.h"
  42.  
  43. # include "StringMe.h"
  44. # include "Definiti.h"
  45. # include "Types.h"
  46. # include "Transfor.h"    /* ExpToVarParam */
  47.  
  48.  
  49.  
  50. static FILE * yyf = stdout;
  51.  
  52. static void yyAbort
  53. # ifdef __cplusplus
  54.  (char * yyFunction)
  55. # else
  56.  (yyFunction) char * yyFunction;
  57. # endif
  58. {
  59.  (void) fprintf (stderr, "Error: module Reductions, routine %s failed\n", yyFunction);
  60.  exit (1);
  61. }
  62.  
  63. bool IsReduction ARGS((tTree t));
  64. tTree GlobalReductionStmt ARGS((tTree var, tTree vtype, tTree func));
  65. tTree GlobalLocReductionStmt ARGS((tTree var, tTree vtype, tTree func));
  66. tTree InitReductionStmt ARGS((tTree var, tTree vtype, tTree func));
  67. tTree ResolveReduce ARGS((tTree t));
  68. static tTree ResolveDoIt ARGS((tTree t, tIdent func, tTree var, tTree exp, tTree other_stmts));
  69. static tTree MakeIntrRedCall ARGS((tIdent fname, tTree var, tTree exp));
  70. static tTree LocationStmts ARGS((tTree params));
  71. static int GetGlobalOp ARGS((tTree type, tIdent redfunc));
  72.  
  73. bool IsReduction
  74. # if defined __STDC__ | defined __cplusplus
  75. (register tTree t)
  76. # else
  77. (t)
  78.  register tTree t;
  79. # endif
  80. {
  81.   if (t == NoTree) return false;
  82.   if (t->Kind == kACF_BASIC) {
  83. # line 57 "Reductions.puma"
  84.   {
  85. # line 58 "Reductions.puma"
  86.    if (! (IsReduction (t->ACF_BASIC.BASIC_STMT))) goto yyL1;
  87.   }
  88.    return true;
  89. yyL1:;
  90.  
  91.   }
  92.   if (t->Kind == kASSIGN_STMT) {
  93.   if (t->ASSIGN_STMT.ASSIGN_EXP->Kind == kFUNC_CALL_EXP) {
  94. # line 61 "Reductions.puma"
  95.   {
  96. # line 62 "Reductions.puma"
  97.    if (! (IsIntrFunc (t->ASSIGN_STMT.ASSIGN_EXP) == true)) goto yyL2;
  98.   {
  99. # line 63 "Reductions.puma"
  100.    if (! (IntrFuncRed (t->ASSIGN_STMT.ASSIGN_EXP->FUNC_CALL_EXP.FUNC_ID->PROC_OBJ.Ident) == true)) goto yyL2;
  101.   }
  102.   }
  103.    return true;
  104. yyL2:;
  105.  
  106.   }
  107.   }
  108.   return false;
  109. }
  110.  
  111. tTree GlobalReductionStmt
  112. # if defined __STDC__ | defined __cplusplus
  113. (register tTree var, register tTree vtype, register tTree func)
  114. # else
  115. (var, vtype, func)
  116.  register tTree var;
  117.  register tTree vtype;
  118.  register tTree func;
  119. # endif
  120. {
  121.   if (func->Kind == kPROC_OBJ) {
  122. # line 85 "Reductions.puma"
  123.  {
  124.   int op;
  125.   tTree t;
  126.   {
  127. # line 87 "Reductions.puma"
  128.  
  129. # line 88 "Reductions.puma"
  130.  
  131. # line 90 "Reductions.puma"
  132.  op = GetGlobalOp (vtype, func->PROC_OBJ.Ident);
  133.  
  134.      if (op == -1)
  135.         { error_protocol ("illegal reduction");
  136.           printf ("Reductions: Generate Global Reduction Statement failed\n");
  137.           printf ("var = "); FileUnparse (stdout, var); printf ("\n");
  138.           printf ("vtype = "); FileUnparse (stdout, vtype); printf ("\n");
  139.           printf ("call = "); FileUnparse (stdout, func); printf ("\n");
  140.           t = NoTree;
  141.         }
  142.       else
  143.         { t = mVAR_PARAM (mADDR (mCONST_EXP (mINT_CONSTANT (op))));
  144.           t = mBTP_LIST (t, mBTP_EMPTY ());
  145.           t = mBTP_LIST (mVAR_PARAM (var), t);
  146.           t = mCALL_STMT (mPROC_OBJ (MakeDalibId ("reduction")), t);
  147.           t = mACF_BASIC (t);
  148.         }
  149.  
  150.   }
  151.   {
  152.    return t;
  153.   }
  154.  }
  155.  
  156.   }
  157.  yyAbort ("GlobalReductionStmt");
  158. }
  159.  
  160. tTree GlobalLocReductionStmt
  161. # if defined __STDC__ | defined __cplusplus
  162. (register tTree var, register tTree vtype, register tTree func)
  163. # else
  164. (var, vtype, func)
  165.  register tTree var;
  166.  register tTree vtype;
  167.  register tTree func;
  168. # endif
  169. {
  170.   if (func->Kind == kPROC_OBJ) {
  171. # line 127 "Reductions.puma"
  172.  {
  173.   int op;
  174.   tTree t;
  175.   {
  176. # line 129 "Reductions.puma"
  177.  
  178. # line 130 "Reductions.puma"
  179.  
  180. # line 132 "Reductions.puma"
  181.  op = GetGlobalOp (vtype, func->PROC_OBJ.Ident);
  182.  
  183.      if ((op < 1) || (op > 6))
  184.         { error_protocol ("illegal loc reduction");
  185.           printf ("GlobalLocReductionStmt failed\n");
  186.           printf ("var = "); FileUnparse (stdout, var); printf ("\n");
  187.           printf ("vtype = "); FileUnparse (stdout, vtype); printf ("\n");
  188.           printf ("call = "); FileUnparse (stdout, func); printf ("\n");
  189.           t = NoTree;
  190.         }
  191.       else
  192.         { t = mVAR_PARAM (mADDR (mCONST_EXP (mINT_CONSTANT (op))));
  193.           t = mBTP_LIST (t, mBTP_EMPTY ());
  194.           t = mBTP_LIST (mVAR_PARAM (var), t);
  195.           t = mCALL_STMT (mPROC_OBJ (MakeDalibId ("pos_reduction")), t);
  196.           t = mACF_BASIC (t);
  197.         }
  198.  
  199.   }
  200.   {
  201.    return t;
  202.   }
  203.  }
  204.  
  205.   }
  206.  yyAbort ("GlobalLocReductionStmt");
  207. }
  208.  
  209. tTree InitReductionStmt
  210. # if defined __STDC__ | defined __cplusplus
  211. (register tTree var, register tTree vtype, register tTree func)
  212. # else
  213. (var, vtype, func)
  214.  register tTree var;
  215.  register tTree vtype;
  216.  register tTree func;
  217. # endif
  218. {
  219. # line 172 "Reductions.puma"
  220.  
  221. tTree t;
  222.  
  223.   if (vtype->Kind == kBOOLEAN_TYPE) {
  224.   if (equalint (vtype->BOOLEAN_TYPE.size, 4)) {
  225.   if (func->Kind == kPROC_OBJ) {
  226.   if (equaltIdent (func->PROC_OBJ.Ident, MakeIdent ("ANY", 3))) {
  227. # line 176 "Reductions.puma"
  228.   {
  229. # line 177 "Reductions.puma"
  230.  t = mCONST_EXP (mBOOL_CONSTANT (0));
  231.      t = mASSIGN_STMT (var, t);
  232.      t = mACF_BASIC (t);
  233.  
  234.   }
  235.    return t;
  236.  
  237.   }
  238.   }
  239.   }
  240.   if (equalint (vtype->BOOLEAN_TYPE.size, 4)) {
  241.   if (func->Kind == kPROC_OBJ) {
  242.   if (equaltIdent (func->PROC_OBJ.Ident, MakeIdent ("ALL", 3))) {
  243. # line 184 "Reductions.puma"
  244.   {
  245. # line 185 "Reductions.puma"
  246.  t = mCONST_EXP (mBOOL_CONSTANT (1));
  247.      t = mASSIGN_STMT (var, t);
  248.      t = mACF_BASIC (t);
  249.  
  250.   }
  251.    return t;
  252.  
  253.   }
  254.   }
  255.   }
  256.   if (equalint (vtype->BOOLEAN_TYPE.size, 4)) {
  257.   if (func->Kind == kPROC_OBJ) {
  258.   if (equaltIdent (func->PROC_OBJ.Ident, MakeIdent ("PARITY", 6))) {
  259. # line 192 "Reductions.puma"
  260.   {
  261. # line 193 "Reductions.puma"
  262.  t = mCONST_EXP (mBOOL_CONSTANT (0));
  263.      t = mASSIGN_STMT (var, t);
  264.      t = mACF_BASIC (t);
  265.  
  266.   }
  267.    return t;
  268.  
  269.   }
  270.   }
  271.   }
  272.   }
  273.   if (vtype->Kind == kINTEGER_TYPE) {
  274.   if (equalint (vtype->INTEGER_TYPE.size, 4)) {
  275.   if (func->Kind == kPROC_OBJ) {
  276.   if (equaltIdent (func->PROC_OBJ.Ident, MakeIdent ("COUNT", 5))) {
  277. # line 200 "Reductions.puma"
  278.   {
  279. # line 201 "Reductions.puma"
  280.  t = mCONST_EXP (mINT_CONSTANT (0));
  281.      t = mASSIGN_STMT (var, t);
  282.      t = mACF_BASIC (t);
  283.  
  284.   }
  285.    return t;
  286.  
  287.   }
  288.   }
  289.   }
  290.   if (equalint (vtype->INTEGER_TYPE.size, 4)) {
  291.   if (func->Kind == kPROC_OBJ) {
  292.   if (equaltIdent (func->PROC_OBJ.Ident, MakeIdent ("SUM", 3))) {
  293. # line 208 "Reductions.puma"
  294.   {
  295. # line 209 "Reductions.puma"
  296.  t = mCONST_EXP (mINT_CONSTANT (0));
  297.      t = mASSIGN_STMT (var, t);
  298.      t = mACF_BASIC (t);
  299.  
  300.   }
  301.    return t;
  302.  
  303.   }
  304.   }
  305.   }
  306.   if (equalint (vtype->INTEGER_TYPE.size, 4)) {
  307.   if (func->Kind == kPROC_OBJ) {
  308.   if (equaltIdent (func->PROC_OBJ.Ident, MakeIdent ("PRODUCT", 7))) {
  309. # line 216 "Reductions.puma"
  310.   {
  311. # line 217 "Reductions.puma"
  312.  t = mCONST_EXP (mINT_CONSTANT (1));
  313.      t = mASSIGN_STMT (var, t);
  314.      t = mACF_BASIC (t);
  315.  
  316.   }
  317.    return t;
  318.  
  319.   }
  320.   }
  321.   }
  322.   if (equalint (vtype->INTEGER_TYPE.size, 4)) {
  323.   if (func->Kind == kPROC_OBJ) {
  324.   if (equaltIdent (func->PROC_OBJ.Ident, MakeIdent ("MAXVAL", 6))) {
  325. # line 224 "Reductions.puma"
  326.   {
  327. # line 225 "Reductions.puma"
  328.  t = mCONST_EXP (mINT_CONSTANT (-2147483647));
  329.      t = mASSIGN_STMT (var, t);
  330.      t = mACF_BASIC (t);
  331.  
  332.   }
  333.    return t;
  334.  
  335.   }
  336.   }
  337.   }
  338.   if (equalint (vtype->INTEGER_TYPE.size, 4)) {
  339.   if (func->Kind == kPROC_OBJ) {
  340.   if (equaltIdent (func->PROC_OBJ.Ident, MakeIdent ("MINVAL", 6))) {
  341. # line 232 "Reductions.puma"
  342.   {
  343. # line 233 "Reductions.puma"
  344.  t = mCONST_EXP (mINT_CONSTANT (2147483647));
  345.      t = mASSIGN_STMT (var, t);
  346.      t = mACF_BASIC (t);
  347.  
  348.   }
  349.    return t;
  350.  
  351.   }
  352.   }
  353.   }
  354.   if (equalint (vtype->INTEGER_TYPE.size, 4)) {
  355.   if (func->Kind == kPROC_OBJ) {
  356.   if (equaltIdent (func->PROC_OBJ.Ident, MakeIdent ("IALL", 4))) {
  357. # line 240 "Reductions.puma"
  358.   {
  359. # line 241 "Reductions.puma"
  360.  t = mCONST_EXP (mINT_CONSTANT (-1));
  361.      t = mASSIGN_STMT (var, t);
  362.      t = mACF_BASIC (t);
  363.  
  364.   }
  365.    return t;
  366.  
  367.   }
  368.   }
  369.   }
  370.   if (equalint (vtype->INTEGER_TYPE.size, 4)) {
  371.   if (func->Kind == kPROC_OBJ) {
  372.   if (equaltIdent (func->PROC_OBJ.Ident, MakeIdent ("IANY", 4))) {
  373. # line 248 "Reductions.puma"
  374.   {
  375. # line 249 "Reductions.puma"
  376.  t = mCONST_EXP (mINT_CONSTANT (0));
  377.      t = mASSIGN_STMT (var, t);
  378.      t = mACF_BASIC (t);
  379.  
  380.   }
  381.    return t;
  382.  
  383.   }
  384.   }
  385.   }
  386.   if (equalint (vtype->INTEGER_TYPE.size, 4)) {
  387.   if (func->Kind == kPROC_OBJ) {
  388.   if (equaltIdent (func->PROC_OBJ.Ident, MakeIdent ("IPARITY", 7))) {
  389. # line 256 "Reductions.puma"
  390.   {
  391. # line 257 "Reductions.puma"
  392.  t = mCONST_EXP (mINT_CONSTANT (0));
  393.      t = mASSIGN_STMT (var, t);
  394.      t = mACF_BASIC (t);
  395.  
  396.   }
  397.    return t;
  398.  
  399.   }
  400.   }
  401.   }
  402.   }
  403.   if (vtype->Kind == kREAL_TYPE) {
  404.   if (equalint (vtype->REAL_TYPE.size, 4)) {
  405.   if (func->Kind == kPROC_OBJ) {
  406.   if (equaltIdent (func->PROC_OBJ.Ident, MakeIdent ("SUM", 3))) {
  407. # line 264 "Reductions.puma"
  408.   {
  409. # line 265 "Reductions.puma"
  410.  t = mCONST_EXP (mREAL_CONSTANT (PutString("0.0",3)));
  411.      t = mASSIGN_STMT (var, t);
  412.      t = mACF_BASIC (t);
  413.  
  414.   }
  415.    return t;
  416.  
  417.   }
  418.   }
  419.   }
  420.   if (equalint (vtype->REAL_TYPE.size, 4)) {
  421.   if (func->Kind == kPROC_OBJ) {
  422.   if (equaltIdent (func->PROC_OBJ.Ident, MakeIdent ("PRODUCT", 7))) {
  423. # line 272 "Reductions.puma"
  424.   {
  425. # line 273 "Reductions.puma"
  426.  t = mCONST_EXP (mREAL_CONSTANT (PutString("1.0",3)));
  427.      t = mASSIGN_STMT (var, t);
  428.      t = mACF_BASIC (t);
  429.  
  430.   }
  431.    return t;
  432.  
  433.   }
  434.   }
  435.   }
  436.   if (equalint (vtype->REAL_TYPE.size, 4)) {
  437.   if (func->Kind == kPROC_OBJ) {
  438.   if (equaltIdent (func->PROC_OBJ.Ident, MakeIdent ("MINVAL", 6))) {
  439. # line 280 "Reductions.puma"
  440.   {
  441. # line 281 "Reductions.puma"
  442.  t = mCONST_EXP (mREAL_CONSTANT (PutString("3.4028235E+38",13)));
  443.      t = mASSIGN_STMT (var, t);
  444.      t = mACF_BASIC (t);
  445.  
  446.   }
  447.    return t;
  448.  
  449.   }
  450.   }
  451.   }
  452.   if (equalint (vtype->REAL_TYPE.size, 4)) {
  453.   if (func->Kind == kPROC_OBJ) {
  454.   if (equaltIdent (func->PROC_OBJ.Ident, MakeIdent ("MAXVAL", 6))) {
  455. # line 288 "Reductions.puma"
  456.   {
  457. # line 289 "Reductions.puma"
  458.  t = mCONST_EXP (mREAL_CONSTANT (PutString("-3.4028235E+38",14)));
  459.      t = mASSIGN_STMT (var, t);
  460.      t = mACF_BASIC (t);
  461.  
  462.   }
  463.    return t;
  464.  
  465.   }
  466.   }
  467.   }
  468.   if (equalint (vtype->REAL_TYPE.size, 8)) {
  469.   if (func->Kind == kPROC_OBJ) {
  470.   if (equaltIdent (func->PROC_OBJ.Ident, MakeIdent ("SUM", 3))) {
  471. # line 296 "Reductions.puma"
  472.   {
  473. # line 297 "Reductions.puma"
  474.  t = mCONST_EXP (mDREAL_CONSTANT (PutString("0.0d0",5)));
  475.      t = mASSIGN_STMT (var, t);
  476.      t = mACF_BASIC (t);
  477.  
  478.   }
  479.    return t;
  480.  
  481.   }
  482.   }
  483.   }
  484.   if (equalint (vtype->REAL_TYPE.size, 8)) {
  485.   if (func->Kind == kPROC_OBJ) {
  486.   if (equaltIdent (func->PROC_OBJ.Ident, MakeIdent ("PRODUCT", 7))) {
  487. # line 304 "Reductions.puma"
  488.   {
  489. # line 305 "Reductions.puma"
  490.  t = mCONST_EXP (mDREAL_CONSTANT (PutString("1.0d0",5)));
  491.      t = mASSIGN_STMT (var, t);
  492.      t = mACF_BASIC (t);
  493.  
  494.   }
  495.    return t;
  496.  
  497.   }
  498.   }
  499.   }
  500.   if (equalint (vtype->REAL_TYPE.size, 8)) {
  501.   if (func->Kind == kPROC_OBJ) {
  502.   if (equaltIdent (func->PROC_OBJ.Ident, MakeIdent ("MINVAL", 6))) {
  503. # line 312 "Reductions.puma"
  504.   {
  505. # line 313 "Reductions.puma"
  506.  t = mCONST_EXP (mDREAL_CONSTANT (PutString("1.797693134862313E+308",22)));
  507.      t = mASSIGN_STMT (var, t);
  508.      t = mACF_BASIC (t);
  509.  
  510.   }
  511.    return t;
  512.  
  513.   }
  514.   }
  515.   }
  516.   if (equalint (vtype->REAL_TYPE.size, 8)) {
  517.   if (func->Kind == kPROC_OBJ) {
  518.   if (equaltIdent (func->PROC_OBJ.Ident, MakeIdent ("MAXVAL", 6))) {
  519. # line 320 "Reductions.puma"
  520.   {
  521. # line 321 "Reductions.puma"
  522.  t = mCONST_EXP (mDREAL_CONSTANT (PutString("-1.797693134862313E+308",23)));
  523.      t = mASSIGN_STMT (var, t);
  524.      t = mACF_BASIC (t);
  525.  
  526.   }
  527.    return t;
  528.  
  529.   }
  530.   }
  531.   }
  532.   }
  533.   if (vtype->Kind == kCOMPLEX_TYPE) {
  534.   if (equalint (vtype->COMPLEX_TYPE.size, 8)) {
  535.   if (func->Kind == kPROC_OBJ) {
  536.   if (equaltIdent (func->PROC_OBJ.Ident, MakeIdent ("SUM", 3))) {
  537. # line 328 "Reductions.puma"
  538.   {
  539. # line 329 "Reductions.puma"
  540.  t = mCONST_EXP (mCOMPLEX_CONSTANT (PutString("0.0",3),
  541.                                         PutString("0.0",3)));
  542.      t = mASSIGN_STMT (var, t);
  543.      t = mACF_BASIC (t);
  544.  
  545.   }
  546.    return t;
  547.  
  548.   }
  549.   }
  550.   }
  551.   if (equalint (vtype->COMPLEX_TYPE.size, 8)) {
  552.   if (func->Kind == kPROC_OBJ) {
  553.   if (equaltIdent (func->PROC_OBJ.Ident, MakeIdent ("PRODUCT", 7))) {
  554. # line 337 "Reductions.puma"
  555.   {
  556. # line 338 "Reductions.puma"
  557.  t = mCONST_EXP (mCOMPLEX_CONSTANT (PutString("1.0",3),
  558.                                         PutString("0.0",3)));
  559.      t = mASSIGN_STMT (var, t);
  560.      t = mACF_BASIC (t);
  561.  
  562.   }
  563.    return t;
  564.  
  565.   }
  566.   }
  567.   }
  568.   }
  569. # line 346 "Reductions.puma"
  570.   {
  571. # line 347 "Reductions.puma"
  572.    error_protocol ("Reductions : initial reduction statement failed");
  573. # line 348 "Reductions.puma"
  574.    printf ("Generate Initial Reduction Statement failed\n");
  575. # line 349 "Reductions.puma"
  576.    printf ("var = ");
  577. # line 349 "Reductions.puma"
  578.    FileUnparse (stdout, var);
  579. # line 349 "Reductions.puma"
  580.    printf ("\n");
  581. # line 350 "Reductions.puma"
  582.    printf ("vtype = ");
  583. # line 350 "Reductions.puma"
  584.    FileUnparse (stdout, vtype);
  585. # line 350 "Reductions.puma"
  586.    printf ("\n");
  587. # line 351 "Reductions.puma"
  588.    printf ("call = ");
  589. # line 351 "Reductions.puma"
  590.    FileUnparse (stdout, func);
  591. # line 351 "Reductions.puma"
  592.    printf ("\n");
  593. # line 352 "Reductions.puma"
  594.    kill_in_protocol ();
  595.   }
  596.    return NoTree;
  597.  
  598. }
  599.  
  600. tTree ResolveReduce
  601. # if defined __STDC__ | defined __cplusplus
  602. (register tTree t)
  603. # else
  604. (t)
  605.  register tTree t;
  606. # endif
  607. {
  608.   if (t->Kind == kACF_BASIC) {
  609.   if (t->ACF_BASIC.BASIC_STMT->Kind == kREDUCE_STMT) {
  610.   if (t->ACF_BASIC.BASIC_STMT->REDUCE_STMT.RED_PARAMS->Kind == kBTP_LIST) {
  611.   if (t->ACF_BASIC.BASIC_STMT->REDUCE_STMT.RED_PARAMS->BTP_LIST.Elem->Kind == kVAR_PARAM) {
  612.   if (t->ACF_BASIC.BASIC_STMT->REDUCE_STMT.RED_PARAMS->BTP_LIST.Next->Kind == kBTP_LIST) {
  613.   if (t->ACF_BASIC.BASIC_STMT->REDUCE_STMT.RED_PARAMS->BTP_LIST.Next->BTP_LIST.Elem->Kind == kVAR_PARAM) {
  614.   if (t->ACF_BASIC.BASIC_STMT->REDUCE_STMT.RED_PARAMS->BTP_LIST.Next->BTP_LIST.Elem->VAR_PARAM.V->Kind == kADDR) {
  615. # line 378 "Reductions.puma"
  616.    return ResolveDoIt (t, t->ACF_BASIC.BASIC_STMT->REDUCE_STMT.RED_FUNC->PROC_OBJ.Ident, t->ACF_BASIC.BASIC_STMT->REDUCE_STMT.RED_PARAMS->BTP_LIST.Elem->VAR_PARAM.V, t->ACF_BASIC.BASIC_STMT->REDUCE_STMT.RED_PARAMS->BTP_LIST.Next->BTP_LIST.Elem->VAR_PARAM.
  617. V->ADDR.E, LocationStmts (t->ACF_BASIC.BASIC_STMT->REDUCE_STMT.RED_PARAMS->BTP_LIST.Next->BTP_LIST.Next));
  618.  
  619.   }
  620. # line 389 "Reductions.puma"
  621.    return ResolveDoIt (t, t->ACF_BASIC.BASIC_STMT->REDUCE_STMT.RED_FUNC->PROC_OBJ.Ident, t->ACF_BASIC.BASIC_STMT->REDUCE_STMT.RED_PARAMS->BTP_LIST.Elem->VAR_PARAM.V, mVAR_EXP (t->ACF_BASIC.BASIC_STMT->REDUCE_STMT.RED_PARAMS->BTP_LIST.Next->BTP_LIST.Elem->
  622. VAR_PARAM.V), LocationStmts (t->ACF_BASIC.BASIC_STMT->REDUCE_STMT.RED_PARAMS->BTP_LIST.Next->BTP_LIST.Next));
  623.  
  624.   }
  625.   }
  626.   }
  627.   }
  628.   }
  629.   }
  630. # line 399 "Reductions.puma"
  631.   {
  632. # line 400 "Reductions.puma"
  633.    printf ("ResolveReduce failed\n");
  634. # line 401 "Reductions.puma"
  635.    WriteTree (stdout, t);
  636. # line 402 "Reductions.puma"
  637.    FileUnparse (stdout, t);
  638. # line 403 "Reductions.puma"
  639.    kill_in_protocol ();
  640.   }
  641.    return NoTree;
  642.  
  643. }
  644.  
  645. static tTree ResolveDoIt
  646. # if defined __STDC__ | defined __cplusplus
  647. (register tTree t, register tIdent func, register tTree var, register tTree exp, register tTree other_stmts)
  648. # else
  649. (t, func, var, exp, other_stmts)
  650.  register tTree t;
  651.  register tIdent func;
  652.  register tTree var;
  653.  register tTree exp;
  654.  register tTree other_stmts;
  655. # endif
  656. {
  657. # line 410 "Reductions.puma"
  658.  
  659. tTree stmt, cond;
  660.  
  661.   if (t->Kind == kACF_BASIC) {
  662.   if (equaltIdent (func, MakeIdent ("COUNT", 5))) {
  663. # line 414 "Reductions.puma"
  664.   {
  665. # line 416 "Reductions.puma"
  666.  stmt = mCONST_EXP(mINT_CONSTANT(1));
  667.       stmt = mOP_EXP (mOP_PLUS(), mVAR_EXP (var), stmt);
  668.       t->ACF_BASIC.BASIC_STMT = mASSIGN_STMT (var, stmt);
  669.  
  670.       stmt = mACF_LIST (t, mACF_EMPTY());
  671.       stmt = mACF_IF (exp, stmt, mACF_EMPTY ());
  672.  
  673.   }
  674.    return stmt;
  675.  
  676.   }
  677.   if (equaltIdent (func, MakeIdent ("ANY", 3))) {
  678. # line 426 "Reductions.puma"
  679.   {
  680. # line 428 "Reductions.puma"
  681.  stmt = mOP_EXP (mOP_OR(), mVAR_EXP (var), exp);
  682.       t->ACF_BASIC.BASIC_STMT = mASSIGN_STMT (CopyTree(var), stmt);
  683.  
  684.   }
  685.    return t;
  686.  
  687.   }
  688.   if (equaltIdent (func, MakeIdent ("PARITY", 6))) {
  689. # line 434 "Reductions.puma"
  690.   {
  691. # line 436 "Reductions.puma"
  692.  stmt = mOP_EXP (mOP_NEQV (), mVAR_EXP (var), exp);
  693.       t->ACF_BASIC.BASIC_STMT = mASSIGN_STMT (CopyTree(var), stmt);
  694.  
  695.   }
  696.    return t;
  697.  
  698.   }
  699.   if (equaltIdent (func, MakeIdent ("ALL", 3))) {
  700. # line 442 "Reductions.puma"
  701.   {
  702. # line 444 "Reductions.puma"
  703.  stmt = mOP_EXP (mOP_AND(), mVAR_EXP (var), exp);
  704.       t->ACF_BASIC.BASIC_STMT = mASSIGN_STMT (CopyTree(var), stmt);
  705.  
  706.   }
  707.    return t;
  708.  
  709.   }
  710.   if (equaltIdent (func, MakeIdent ("SUM", 3))) {
  711. # line 450 "Reductions.puma"
  712.   {
  713. # line 452 "Reductions.puma"
  714.  stmt = mOP_EXP (mOP_PLUS(), mVAR_EXP (var), exp);
  715.       t->ACF_BASIC.BASIC_STMT = mASSIGN_STMT (CopyTree(var), stmt);
  716.  
  717.   }
  718.    return t;
  719.  
  720.   }
  721.   if (equaltIdent (func, MakeIdent ("PRODUCT", 7))) {
  722. # line 458 "Reductions.puma"
  723.   {
  724. # line 460 "Reductions.puma"
  725.  stmt = mOP_EXP (mOP_TIMES(), mVAR_EXP (var), exp);
  726.       t->ACF_BASIC.BASIC_STMT = mASSIGN_STMT (CopyTree(var), stmt);
  727.  
  728.   }
  729.    return t;
  730.  
  731.   }
  732.   if (equaltIdent (func, MakeIdent ("IALL", 4))) {
  733. # line 466 "Reductions.puma"
  734.   {
  735. # line 468 "Reductions.puma"
  736.  t->ACF_BASIC.BASIC_STMT = MakeIntrRedCall (MakeIdent ("IAND",4), var, exp);
  737.   }
  738.    return t;
  739.  
  740.   }
  741.   if (equaltIdent (func, MakeIdent ("IANY", 4))) {
  742. # line 472 "Reductions.puma"
  743.   {
  744. # line 474 "Reductions.puma"
  745.  t->ACF_BASIC.BASIC_STMT = MakeIntrRedCall (MakeIdent ("IOR",3), var, exp);
  746.   }
  747.    return t;
  748.  
  749.   }
  750.   if (equaltIdent (func, MakeIdent ("IPARITY", 7))) {
  751. # line 478 "Reductions.puma"
  752.   {
  753. # line 480 "Reductions.puma"
  754.  t->ACF_BASIC.BASIC_STMT = MakeIntrRedCall (MakeIdent ("IEOR",4), var, exp);
  755.   }
  756.    return t;
  757.  
  758.   }
  759.   if (equaltIdent (func, MakeIdent ("MINVAL", 6))) {
  760. # line 484 "Reductions.puma"
  761.   {
  762. # line 486 "Reductions.puma"
  763.  cond = mOP_EXP (mOP_LT(), exp, mVAR_EXP (var));
  764.       t->ACF_BASIC.BASIC_STMT = mASSIGN_STMT (CopyTree(var), CopyTree(exp));
  765.  
  766.       stmt = mACF_LIST (t, other_stmts);
  767.       stmt = mACF_IF (cond, stmt, mACF_EMPTY ());
  768.  
  769.   }
  770.    return stmt;
  771.  
  772.   }
  773.   if (equaltIdent (func, MakeIdent ("MAXVAL", 6))) {
  774. # line 495 "Reductions.puma"
  775.   {
  776. # line 497 "Reductions.puma"
  777.  cond = mOP_EXP (mOP_GT(), exp, mVAR_EXP (var));
  778.       t->ACF_BASIC.BASIC_STMT = mASSIGN_STMT (CopyTree(var), CopyTree(exp));
  779.  
  780.       stmt = mACF_LIST (t, other_stmts);
  781.       stmt = mACF_IF (cond, stmt, mACF_EMPTY ());
  782.  
  783.   }
  784.    return stmt;
  785.  
  786.   }
  787.   }
  788. # line 506 "Reductions.puma"
  789.   {
  790. # line 507 "Reductions.puma"
  791.    printf ("Reductions: ResolveReduce failed\n");
  792. # line 508 "Reductions.puma"
  793.    FileUnparse (stdout, t);
  794. # line 509 "Reductions.puma"
  795.    kill_in_protocol ();
  796.   }
  797.    return NoTree;
  798.  
  799. }
  800.  
  801. static tTree MakeIntrRedCall
  802. # if defined __STDC__ | defined __cplusplus
  803. (register tIdent fname, register tTree var, register tTree exp)
  804. # else
  805. (fname, var, exp)
  806.  register tIdent fname;
  807.  register tTree var;
  808.  register tTree exp;
  809. # endif
  810. {
  811. # line 521 "Reductions.puma"
  812.  {
  813.   tTree p;
  814.   tTree f;
  815.   {
  816. # line 523 "Reductions.puma"
  817.  
  818. # line 524 "Reductions.puma"
  819.  
  820. # line 526 "Reductions.puma"
  821.  p = mBTP_EMPTY ();
  822.       p = mBTP_LIST (ExpToVarParam (exp), p);
  823.       p = mBTP_LIST (mVAR_PARAM (var), p);
  824.       f = mPROC_OBJ (fname);
  825.       f -> PROC_OBJ.Object = GetDeclEntry (fname, GetIntrinsicEntries ());
  826.       f = mFUNC_CALL_EXP (f, p);
  827.       f = mASSIGN_STMT (CopyTree (var), f);
  828.  
  829.   }
  830.   {
  831.    return f;
  832.   }
  833.  }
  834.  
  835. }
  836.  
  837. static tTree LocationStmts
  838. # if defined __STDC__ | defined __cplusplus
  839. (register tTree params)
  840. # else
  841. (params)
  842.  register tTree params;
  843. # endif
  844. {
  845. # line 549 "Reductions.puma"
  846.  
  847. tTree stmt;
  848.  
  849.   if (params->Kind == kBTP_EMPTY) {
  850. # line 553 "Reductions.puma"
  851.    return mACF_EMPTY ();
  852.  
  853.   }
  854.   if (params->Kind == kBTP_LIST) {
  855.   if (params->BTP_LIST.Elem->Kind == kVAR_PARAM) {
  856.   if (params->BTP_LIST.Next->Kind == kBTP_LIST) {
  857.   if (params->BTP_LIST.Next->BTP_LIST.Elem->Kind == kVAR_PARAM) {
  858.   if (params->BTP_LIST.Next->BTP_LIST.Elem->VAR_PARAM.V->Kind == kADDR) {
  859. # line 557 "Reductions.puma"
  860.   {
  861. # line 558 "Reductions.puma"
  862.  stmt = mASSIGN_STMT (params->BTP_LIST.Elem->VAR_PARAM.V, params->BTP_LIST.Next->BTP_LIST.Elem->VAR_PARAM.V->ADDR.E);
  863.       stmt = mACF_BASIC (stmt);
  864.  
  865.   }
  866.    return mACF_LIST (stmt, LocationStmts (params->BTP_LIST.Next->BTP_LIST.Next));
  867.  
  868.   }
  869. # line 564 "Reductions.puma"
  870.   {
  871. # line 565 "Reductions.puma"
  872.  stmt = mASSIGN_STMT (params->BTP_LIST.Elem->VAR_PARAM.V, mVAR_EXP (params->BTP_LIST.Next->BTP_LIST.Elem->VAR_PARAM.V));
  873.       stmt = mACF_BASIC (stmt);
  874.  
  875.   }
  876.    return mACF_LIST (stmt, LocationStmts (params->BTP_LIST.Next->BTP_LIST.Next));
  877.  
  878.   }
  879.   }
  880.   }
  881.   }
  882.  yyAbort ("LocationStmts");
  883. }
  884.  
  885. static int GetGlobalOp
  886. # if defined __STDC__ | defined __cplusplus
  887. (register tTree type, register tIdent redfunc)
  888. # else
  889. (type, redfunc)
  890.  register tTree type;
  891.  register tIdent redfunc;
  892. # endif
  893. {
  894.   if (type->Kind == kBOOLEAN_TYPE) {
  895.   if (equalint (type->BOOLEAN_TYPE.size, 4)) {
  896.   if (equaltIdent (redfunc, MakeIdent ("ANY", 3))) {
  897. # line 581 "Reductions.puma"
  898.    return 17;
  899.  
  900.   }
  901.   }
  902.   if (equalint (type->BOOLEAN_TYPE.size, 4)) {
  903.   if (equaltIdent (redfunc, MakeIdent ("ALL", 3))) {
  904. # line 583 "Reductions.puma"
  905.    return 16;
  906.  
  907.   }
  908.   }
  909.   if (equalint (type->BOOLEAN_TYPE.size, 4)) {
  910.   if (equaltIdent (redfunc, MakeIdent ("PARITY", 6))) {
  911. # line 585 "Reductions.puma"
  912.    return 18;
  913.  
  914.   }
  915.   }
  916.   }
  917.   if (type->Kind == kINTEGER_TYPE) {
  918.   if (equalint (type->INTEGER_TYPE.size, 4)) {
  919.   if (equaltIdent (redfunc, MakeIdent ("SUM", 3))) {
  920. # line 587 "Reductions.puma"
  921.    return 7;
  922.  
  923.   }
  924.   }
  925.   if (equalint (type->INTEGER_TYPE.size, 4)) {
  926.   if (equaltIdent (redfunc, MakeIdent ("PRODUCT", 7))) {
  927. # line 589 "Reductions.puma"
  928.    return 10;
  929.  
  930.   }
  931.   }
  932.   if (equalint (type->INTEGER_TYPE.size, 4)) {
  933.   if (equaltIdent (redfunc, MakeIdent ("MINVAL", 6))) {
  934. # line 591 "Reductions.puma"
  935.    return 1;
  936.  
  937.   }
  938.   }
  939.   if (equalint (type->INTEGER_TYPE.size, 4)) {
  940.   if (equaltIdent (redfunc, MakeIdent ("MAXVAL", 6))) {
  941. # line 593 "Reductions.puma"
  942.    return 4;
  943.  
  944.   }
  945.   }
  946.   if (equalint (type->INTEGER_TYPE.size, 4)) {
  947.   if (equaltIdent (redfunc, MakeIdent ("IALL", 4))) {
  948. # line 595 "Reductions.puma"
  949.    return 13;
  950.  
  951.   }
  952.   }
  953.   if (equalint (type->INTEGER_TYPE.size, 4)) {
  954.   if (equaltIdent (redfunc, MakeIdent ("IANY", 4))) {
  955. # line 597 "Reductions.puma"
  956.    return 14;
  957.  
  958.   }
  959.   }
  960.   if (equalint (type->INTEGER_TYPE.size, 4)) {
  961.   if (equaltIdent (redfunc, MakeIdent ("IPARITY", 7))) {
  962. # line 599 "Reductions.puma"
  963.    return 15;
  964.  
  965.   }
  966.   }
  967.   if (equalint (type->INTEGER_TYPE.size, 4)) {
  968.   if (equaltIdent (redfunc, MakeIdent ("COUNT", 5))) {
  969. # line 601 "Reductions.puma"
  970.    return 7;
  971.  
  972.   }
  973.   }
  974.   }
  975.   if (type->Kind == kREAL_TYPE) {
  976.   if (equalint (type->REAL_TYPE.size, 4)) {
  977.   if (equaltIdent (redfunc, MakeIdent ("SUM", 3))) {
  978. # line 603 "Reductions.puma"
  979.    return 8;
  980.  
  981.   }
  982.   }
  983.   if (equalint (type->REAL_TYPE.size, 4)) {
  984.   if (equaltIdent (redfunc, MakeIdent ("PRODUCT", 7))) {
  985. # line 605 "Reductions.puma"
  986.    return 11;
  987.  
  988.   }
  989.   }
  990.   if (equalint (type->REAL_TYPE.size, 4)) {
  991.   if (equaltIdent (redfunc, MakeIdent ("MINVAL", 6))) {
  992. # line 607 "Reductions.puma"
  993.    return 2;
  994.  
  995.   }
  996.   }
  997.   if (equalint (type->REAL_TYPE.size, 4)) {
  998.   if (equaltIdent (redfunc, MakeIdent ("MAXVAL", 6))) {
  999. # line 609 "Reductions.puma"
  1000.    return 5;
  1001.  
  1002.   }
  1003.   }
  1004.   if (equalint (type->REAL_TYPE.size, 8)) {
  1005.   if (equaltIdent (redfunc, MakeIdent ("SUM", 3))) {
  1006. # line 611 "Reductions.puma"
  1007.    return 9;
  1008.  
  1009.   }
  1010.   }
  1011.   if (equalint (type->REAL_TYPE.size, 8)) {
  1012.   if (equaltIdent (redfunc, MakeIdent ("PRODUCT", 7))) {
  1013. # line 613 "Reductions.puma"
  1014.    return 12;
  1015.  
  1016.   }
  1017.   }
  1018.   if (equalint (type->REAL_TYPE.size, 8)) {
  1019.   if (equaltIdent (redfunc, MakeIdent ("MINVAL", 6))) {
  1020. # line 615 "Reductions.puma"
  1021.    return 3;
  1022.  
  1023.   }
  1024.   }
  1025.   if (equalint (type->REAL_TYPE.size, 8)) {
  1026.   if (equaltIdent (redfunc, MakeIdent ("MAXVAL", 6))) {
  1027. # line 617 "Reductions.puma"
  1028.    return 6;
  1029.  
  1030.   }
  1031.   }
  1032.   }
  1033.   if (type->Kind == kCOMPLEX_TYPE) {
  1034.   if (equalint (type->COMPLEX_TYPE.size, 8)) {
  1035.   if (equaltIdent (redfunc, MakeIdent ("SUM", 3))) {
  1036. # line 619 "Reductions.puma"
  1037.    return 19;
  1038.  
  1039.   }
  1040.   }
  1041.   }
  1042. # line 621 "Reductions.puma"
  1043.   {
  1044. # line 622 "Reductions.puma"
  1045.    error_protocol ("This reduction is not handled within ADAPTOR");
  1046. # line 623 "Reductions.puma"
  1047.    tree_protocol ("type is ", type);
  1048.   }
  1049.    return - 1;
  1050.  
  1051. }
  1052.  
  1053. void BeginReductions ()
  1054. {
  1055. }
  1056.  
  1057. void CloseReductions ()
  1058. {
  1059. }
  1060.